home *** CD-ROM | disk | FTP | other *** search
/ System Booster / System Booster.iso / Archives / HardwareProjects / VideoText.lha / VideoText4.2 / source / sys.p < prev    next >
Encoding:
Text File  |  1995-06-21  |  21.4 KB  |  658 lines
  1. UNIT sys; {$project vt}
  2. { Betriebssystemnahe Funktionen zum Programm VideoText }
  3.  
  4. INTERFACE;
  5.  
  6. TYPE Str80 = String[80];
  7.  
  8. VAR Con: Ptr;  { darf nicht vom ExitServer geschlossen werden, komisch }
  9.     stop,mouseclicked: Boolean;
  10.     clickedx,clickedy: Integer;  { Intuition-Ereignisse }
  11.     palette: ARRAY[0..7] OF Word;
  12.     colperm: Long;
  13.  
  14. PROCEDURE intui_events;
  15. FUNCTION readkey: Char;
  16. FUNCTION waitkey: Char;
  17. FUNCTION fileselect(was_los: str80; speichern: boolean;
  18.                                    var selected: str80): Boolean;
  19. PROCEDURE create_icon(VAR src,dest: Str80);
  20. PROCEDURE scroll_text(zl0,zl1, sp0,sp1, dy,dx: Integer);
  21. PROCEDURE stretch_line(zeile, sp0, sp1: Integer);
  22. PROCEDURE raster_line(zeile, sp0, sp1: Integer; farbe: Word);
  23. FUNCTION bitmapzeile(plane,line: Integer): Ptr;
  24. PROCEDURE busy_pointer;
  25. PROCEDURE normal_pointer;
  26. PROCEDURE showscreen(mine: Boolean);
  27. PROCEDURE force_time(VAR s: Str80);
  28. PROCEDURE start_clip(size: Long);
  29. PROCEDURE clip_it(s: Str; len: Long);
  30. PROCEDURE end_clip;
  31. PROCEDURE telltime(VAR day,min,tic: Long);
  32. PROCEDURE desaster(meldung: Str80);
  33. PROCEDURE sysinit(version: Str);
  34. PROCEDURE sysclean;
  35.  
  36. { ---------------------------------------------------------------------- }
  37.  
  38. IMPLEMENTATION;
  39.  
  40. {$opt q,s+,i+ } { keine Laufzeitprüfungen außer Stack und Feldindizes }
  41. {$incl "intuition.lib", "graphics.lib" }
  42. {$incl "diskfont.lib", "dos.lib", "req.lib", "icon.lib", "asl.lib" }
  43. {$incl "exec.lib", "devices/timer.h", "devices/clipboard.h" }
  44.  
  45. TYPE WordArr36 = ARRAY [1..36] OF Word;
  46.      IntArr10 = ARRAY [1..10] OF Integer;
  47.  
  48. VAR NeuerScreen: ExtNewScreen;  STATIC;
  49.     MyScreen: p_Screen;
  50.     Tags: Array[1..5] OF TagItem;  STATIC;
  51.     Pens: Array[0..NUMDRIPENS] OF Integer;  STATIC;
  52.     titel: Str80;  STATIC;
  53.     NeuesWindow: NewWindow;  STATIC;
  54.     myprocess: p_Process;
  55.     MyWindow,oldwindowptr: p_Window;
  56.     Menue1: Menu; STATIC;
  57.     Mi: Array[1..5] OF MenuItem; STATIC;
  58.     MiT: Array[1..5] OF IntuiText; STATIC;
  59.     breite,hoehe: Integer;
  60.     topazAttr,teleAttr: TextAttr;
  61.     teleFont: p_TextFont;
  62.     BusyPointerData: ^WordArr36;
  63.     { für die req.library: }
  64.     MyFileReq: ReqFileRequester; STATIC;
  65.     pfad: Array[0..DSIZE] OF Char; STATIC;
  66.     name: Array[0..FCHARS] OF Char; STATIC;
  67.     pfadname: Array[-DSIZE..FCHARS] OF Char; STATIC;
  68.     { fürs clipboard.device: }
  69.     clip_port: ^MsgPort;
  70.     clipreq: ^IOClipReq; { erweiterte IO-Request-Struktur }
  71.     clip_open: Boolean;
  72.     { für den Aushilfs-Requester: }
  73.     MyRequest: Requester; STATIC;
  74.     TextGad: Gadget; STATIC;
  75.     TextInfo: StringInfo; STATIC;
  76.     Ueberschrift: IntuiText; STATIC;
  77.     Borders: ARRAY [1..6] OF Border; STATIC;
  78.     TextBordXY,MainBordXY: IntArr10; STATIC;
  79.  
  80. PROCEDURE intui_events;
  81. { überträgt Intuition-Ereignisse (z. B. Menuepunkt 'Quit') in globale }
  82. { Variablen. }
  83. VAR Msg: ^IntuiMessage;
  84.     item,men,menitem,subitem: Word;
  85.     item_address: ^MenuItem;
  86.     charx,chary: Integer;
  87. BEGIN
  88.   REPEAT
  89.     Msg := Get_Msg(MyWindow^.UserPort);
  90.     IF Msg<>Nil THEN BEGIN
  91.       CASE Msg^.class OF
  92.         MOUSEBUTTONS: IF Msg^.code=SELECTDOWN THEN BEGIN
  93.             mouseclicked := True;
  94.             charx := MyWindow^.RPort^.TxWidth;
  95.             chary := MyWindow^.RPort^.TxHeight;
  96.             clickedx := 1 + (Msg^.MouseX - MyWindow^.BorderLeft) DIV charx;
  97.             clickedy := 1 + (Msg^.MouseY - MyWindow^.BorderTop) DIV chary;
  98.           END;
  99.         MENUPICK: BEGIN
  100.           item := Msg^.Code;
  101.           WHILE item<>MENUNULL DO BEGIN
  102.             { item nach Menue, Menuepunkt und Untermenue aufschlüsseln }
  103.             men:=item AND %00011111;
  104.             menitem:=(item SHR 5) AND %00111111;
  105.             subitem:=(item SHR 11) AND %00011111;
  106.             IF (men=0) AND (menitem=0) THEN
  107.               stop := True;
  108.             item_address := ItemAddress(^Menue1,item);
  109.             item := item_address^.NextSelect;
  110.           END;
  111.         END;
  112.         OTHERWISE;
  113.       END;
  114.       Reply_Msg(Msg);
  115.     END;
  116.   UNTIL Msg=Nil;
  117. END;
  118.  
  119. FUNCTION readkey{: Char};
  120. BEGIN
  121.   readkey := ReadCon(Con);
  122. END;
  123.  
  124. FUNCTION waitkey{: Char};
  125. VAR taste: Char;
  126.     sig: Long;
  127. BEGIN
  128.   REPEAT
  129.     sig := Wait(-1);
  130.     taste := ReadCon(Con);
  131.   UNTIL taste <> Chr(0);
  132.   waitkey := taste;
  133. END;
  134.  
  135. FUNCTION fileselect{(was_los: str80; speichern: Boolean;
  136.                                    VAR selected: str80): Boolean};
  137. { Benutzt, wenn vorhanden, den Filerequester der req.library, }
  138. { sonst den aus der asl.library, und notfalls ein Stringgadget. }
  139. VAR i,p,l: Integer;
  140.     Req: p_FileRequester;
  141.     Msg: p_IntuiMessage;
  142.     ende: Boolean;
  143.     class: Long;
  144.     b,h: Word;
  145.     buf,ubuf: str80;
  146.     muell: ARRAY[0..31] OF Byte;
  147. BEGIN
  148.   fileselect := False;
  149.   l := Length(selected);
  150.   { selected in pfad und name spalten }
  151.   p := 0; FOR i := 1 TO l DO
  152.     IF selected[i] IN ['/',':'] THEN p := i;
  153.   IF p=0 THEN pfad := '' ELSE pfad := Copy(selected,1,p);
  154.   IF p=l THEN name := '' ELSE name := Copy(selected,p+1,l-p);
  155.   IF AslBase<>Nil THEN BEGIN            { *** "asl.library" benutzen }
  156.     Tags[1] := TagItem(ASL_Hail,Long(^was_los));
  157.     Tags[2] := TagItem(ASL_Dir,Long(^pfad));
  158.     Tags[3] := TagItem(ASL_File,Long(^name));
  159.     Tags[4] := TagItem(ASL_Window,Long(MyWindow));
  160.     Tags[5] := TagItem(TAG_DONE,0);
  161.     Req := AllocAslRequest(ASL_FileRequest,^Tags);
  162.     IF Req<>NIL THEN BEGIN
  163.       IF RequestFile(Req) THEN
  164.         IF Req^.rf_File<>'' THEN BEGIN
  165.           fileselect := True;
  166.           pfad := Req^.rf_Dir; l := Length(pfad);
  167.           name := Req^.rf_File;
  168.           IF pfad[l-1] IN [':','/'] THEN
  169.             selected := pfad+name
  170.           ELSE
  171.             selected := pfad+'/'+name;
  172.         END;
  173.       FreeAslRequest(Req);
  174.     END;
  175.   END ELSE IF ReqBase<>Nil THEN BEGIN  { *** "req.library" benutzen }
  176.     WITH MyFileReq DO BEGIN
  177.       VersionNumber := REQVERSION;
  178.       Title := was_los;
  179.       PathName := pfadname;   { Str-Zeiger auf meinen Puffer setzen }
  180.       Dir := pfad;
  181.       _File := name;
  182.       WindowLeftEdge := 128;
  183.       WindowTopEdge := 25;
  184.       Flags := FRQABSOLUTEXYM;
  185.       IF speichern THEN
  186.         Flags := Flags OR FRQSAVINGM
  187.       ELSE
  188.         Flags := Flags OR FRQLOADINGM;
  189.       { dran denken, Hintergrund türkis }
  190.       filenamescolor := 1;    { schwarz }
  191.       dirnamescolor := 2;     { weiß }
  192.       devicenamescolor := 1;  { schwarz }
  193.       detailcolor := 6;       { grün }
  194.       blockcolor := 1;        { schwarz }
  195.       gadgettextcolor := 1;   { schwarz }
  196.       stringgadgetcolor := 1; { schwarz }
  197.       textmessagecolor := 7;  { gelb }
  198.       stringnamecolor := 7;   { gelb }
  199.       boxbordercolor := 5;    { blau }
  200.       gadgetboxcolor := 5;    { blau }
  201.     END;
  202.     IF _FileRequester(^MyFileReq) THEN BEGIN
  203.       fileselect := True;
  204.       selected := pfadname;
  205.     END;
  206.   END ELSE BEGIN  { *** einfacher Requester mit Stringgadget }
  207.     buf := selected; ubuf := '';
  208.     b := 8*50 + 30;  IF Length(was_los)>50  THEN b := 8*Length(was_los) + 30;
  209.     h := 9 + 8 + 20;
  210.     Ueberschrift:=IntuiText(1,3,JAM1,15,6,Nil,was_los,Nil);
  211.     TextBordXY:=IntArr10(-1,8,400,8,400,-1,-1,-1,-1,8);
  212.     Borders[1] := Border(0,0,2,0,JAM1,3,^TextBordXY,^Borders[2]);
  213.     Borders[2] := Border(0,0,1,0,JAM1,3,^TextBordXY[5],Nil);
  214.     TextInfo := StringInfo(^buf,^ubuf,0,79,0,0,0,0,0,0,Nil,0,Nil);
  215.     TextGad := Gadget(Nil,(b-8*50) DIV 2,9+12,8*50,8,GADGHCOMP,
  216.       RELVERIFY OR ENDGADGET, STRGADGET OR REQGADGET,
  217.       ^Borders[1], Nil,Nil,0,^TextInfo,2,Nil);
  218.     MainBordXY := IntArr10(0,h-1,b-1,h-1,b-1,0,0,0,0,h-1);
  219.     Borders[3] := Border(0,0,1,0,JAM1,3,^MainBordXY,^Borders[4]);
  220.     Borders[4] := Border(0,0,2,0,JAM1,3,^MainBordXY[5],Nil);
  221.     MyRequest := Requester(Nil,70,90,b,h,0,0,^TextGad,^Borders[3],
  222.         ^Ueberschrift,0,(colperm SHR 12) AND $F,Nil,muell,Nil,Nil,Nil,muell);
  223.     IF Request(^MyRequest,MyWindow) THEN BEGIN { Ereignisse abfragen }
  224.       ende := False;
  225.       REPEAT
  226.         REPEAT              { Schleife, da mehrere Ereignisse möglich }
  227.           Msg := Get_Msg(MyWindow^.UserPort);
  228.           IF Msg<>Nil THEN BEGIN
  229.             class := Msg^.Class;
  230.             Reply_Msg(Msg);             { so schnell wie möglich antworten! }
  231.             IF class=REQSET THEN
  232.               IF NOT ActivateGadget(^TextGad,MyWindow,^MyRequest) THEN;
  233.             IF class=REQCLEAR THEN ende := True;
  234.           END;
  235.         UNTIL Msg=Nil;
  236.         IF NOT ende THEN class := Wait(-1);
  237.       UNTIL ende;
  238.       IF buf<>'' THEN BEGIN
  239.         fileselect := True;
  240.         selected := buf;
  241.       END;
  242.     END;
  243.   END;
  244. END;
  245.  
  246. PROCEDURE create_icon{(VAR src,dest: Str80)};
  247. VAR icon: p_DiskObject;
  248. BEGIN
  249.   IF (IconBase<>Nil) AND (src<>'') THEN BEGIN
  250.     icon := GetDiskObject(src);
  251.     IF icon<>Nil THEN BEGIN
  252.       icon^.do_CurrentX := NO_ICON_POSITION;
  253.       icon^.do_CurrentY := NO_ICON_POSITION;
  254.       icon^.do_Type := WBPROJECT;
  255.       IF NOT PutDiskObject(dest,icon) THEN;
  256.       FreeDiskObject(icon);
  257.     END;
  258.   END;
  259. END;
  260.  
  261. PROCEDURE scroll_text{(zl0,zl1, sp0,sp1, dy,dx: Integer)};
  262. { einen Textblock verschieben, benutzt natürlich ScrollRaster() }
  263. { Zeilen und Spalten werden, wie bei GotoXY üblich, ab 1 gezählt! }
  264. VAR charx,chary,i,x0,y0,x1,y1: Integer;
  265. BEGIN
  266.   charx := MyWindow^.RPort^.TxWidth;
  267.   chary := MyWindow^.RPort^.TxHeight;
  268.   dx := dx*charx; dy := dy*chary;
  269.   x0 := (sp0-1)*charx; x1 := sp1*charx-1;
  270.   y0 := (zl0-1)*chary; y1 := zl1*chary-1;
  271.   ScrollRaster(MyWindow^.RPort,dx,dy,x0,y0,x1,y1);
  272. END;
  273.  
  274. PROCEDURE stretch_line{(zeile, sp0, sp1: Integer)};
  275. { Streckt eine Textzeile am Bildschirm von sp0 bis einschließlich sp1 auf }
  276. { doppelte Höhe. }
  277. { Zeilen und Spalten werden, wie bei GotoXY üblich, ab 1 gezählt! }
  278. VAR charx,chary,i,y0,x0,breite: Integer;
  279. BEGIN
  280.   charx := MyWindow^.RPort^.TxWidth;
  281.   chary := MyWindow^.RPort^.TxHeight;
  282.   x0 := (sp0-1)*charx; breite := (sp1-sp0+1)*charx;
  283.   y0 := (zeile-1)*chary;
  284.   FOR i := chary-1 DOWNTO 0 DO BEGIN
  285.     ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i,breite,1,$C0);
  286.     ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i+1,breite,1,$C0);
  287.   END;
  288. END;
  289.  
  290. PROCEDURE raster_line{(zeile, sp0, sp1: Integer; farbe: Word)};
  291. { Grafikzeichen einer Zeile in seperate Rasterpunkte zerlegen, dazu dient }
  292. { Zeichen #128 des videotext.font }
  293. VAR charx,chary,baseline,y0,x0,i,anz: Integer;
  294.     dummy: str80;
  295.     egal: Long;
  296. BEGIN
  297.   charx := MyWindow^.RPort^.TxWidth;
  298.   chary := MyWindow^.RPort^.TxHeight;
  299.   baseline := MyWindow^.RPort^.TxBaseline;
  300.   x0 := (sp0-1)*charx; y0 := (zeile-1)*chary + baseline;
  301.   anz := sp1-sp0+1;
  302.   FOR i := 1 TO anz DO dummy[i] := #128;
  303.   SetAPen(MyWindow^.RPort,farbe); SetDrMd(MyWindow^.RPort,INVERSVID);
  304.   Move(MyWindow^.RPort,x0,y0); egal := _Text(MyWindow^.RPort,dummy,anz);
  305. END;
  306.  
  307. FUNCTION bitmapzeile{(plane,line: Integer): Ptr};
  308. VAR map: p_BitMap;
  309.     y0: Integer;
  310. BEGIN
  311.   map := MyWindow^.RPort^.BitMap;
  312.   y0 := MyWindow^.TopEdge + MyWindow^.BorderTop;
  313.   bitmapzeile := Ptr(Long(map^.Planes[plane]) + (y0+line)*map^.BytesPerRow);
  314. END;
  315.  
  316. PROCEDURE busy_pointer;
  317. BEGIN
  318.   IF BusyPointerData<>Nil THEN
  319.     SetPointer(MyWindow, BusyPointerData, 16, 16, -6, 0);
  320. END;
  321.  
  322. PROCEDURE normal_pointer;
  323. BEGIN
  324.   ClearPointer(MyWindow);
  325. END;
  326.  
  327. PROCEDURE showscreen{(mine: Boolean)};
  328. BEGIN
  329.   IF mine THEN
  330.     ScreenToFront(MyScreen)
  331.   ELSE
  332.     IF NOT WBenchToFront THEN { Workbench gar nicht offen, na toll };
  333. END;
  334.  
  335. { ## Dies sind *nicht* die Original-Funktionen aus dem Unit ExecSupport! }
  336. { ## Für meine Zwecke sind sie aber gut genug: }
  337.  
  338. FUNCTION CreatePort (name: Str; pri: Byte) : p_MsgPort;
  339. VAR port   : p_MsgPort;
  340.     sigbit : Byte;
  341. BEGIN
  342.   port := Ptr (Alloc_Mem (SizeOf(MsgPort), MEMF_CLEAR or MEMF_PUBLIC ));
  343.   sigbit := AllocSignal(-1);
  344.   IF sigbit <> -1 THEN
  345.     WITH port^, mp_Node DO BEGIN
  346.       ln_Name := name;
  347.       ln_Pri := pri;
  348.       ln_Type := NT_MSGPORT;
  349.       mp_Flags := PA_SIGNAL;
  350.       mp_SigBit := sigbit;
  351.       mp_SigTask := FindTask(Nil);
  352.       AddPort (port);
  353.     END;
  354.   CreatePort := port;
  355. END;
  356.  
  357. PROCEDURE DeletePort (port: p_MsgPort);
  358. BEGIN
  359.   RemPort (port);
  360.   port^.mp_Node.ln_Type := $FF;
  361.   port^.mp_MsgList.lh_head := Ptr(-1);
  362.   FreeSignal (port^.mp_SigBit);
  363.   Free_Mem (Long(port), SizeOf (port^) )
  364. END;
  365.  
  366. FUNCTION CreateExtIO (ioReplyPort: p_MsgPort; size: Long) : Ptr;
  367. VAR ioReq: p_IORequest;
  368. BEGIN
  369.   IF ioReplyPort=Nil THEN
  370.     CreateExtIO := Nil
  371.   ELSE BEGIN
  372.     ioReq := Ptr (Alloc_Mem (size, MEMF_CLEAR or MEMF_PUBLIC));
  373.     WITH ioReq^, io_Message DO BEGIN
  374.       mn_Node.ln_Type := NT_MESSAGE;
  375.       mn_Length := size;
  376.       mn_ReplyPort := ioReplyPort;
  377.     END;
  378.     CreateExtIO := ioReq;
  379.   END;
  380. END;
  381.  
  382. PROCEDURE DeleteExtIO (ioExt: Ptr);
  383. VAR io: p_IoRequest;
  384. BEGIN
  385.   io := ioExt;
  386.   IF io <> Nil THEN
  387.     WITH io^ DO BEGIN
  388.       io_Message.mn_Node.ln_Type := $FF;
  389.       io_Device := Ptr(-1);
  390.       io_Unit := Ptr(-1);
  391.       Free_Mem (Long (ioExt), io^.io_Message.mn_Length)
  392.     END;
  393. END;
  394.  
  395. { ## Ende der nachgemachten ExecSupport-Funktionen }
  396.  
  397. PROCEDURE force_time{(VAR s: Str80)};
  398. { setzt die Systemzeit (Tageszeit), Datum bleibt unverändert }
  399. VAR port: ^MsgPort;
  400.     t_ioreq: ^TimeRequest;
  401.     err: Integer;
  402.     secs,w: Long;
  403.     i,j: Integer;
  404. CONST spd=60*60*24;
  405. BEGIN
  406.   { Uhrzeit-String "09:12:35", "912/35" o. ä. in Sekunden umrechnen }
  407.   secs := 0; j := 0; w := 1; { w: Wert der Ziffer }
  408.   FOR i := Length(s) DOWNTO 1 DO BEGIN
  409.     IF s[i] IN ['0'..'9'] THEN BEGIN
  410.       secs := secs + w*(Ord(s[i])-48);
  411.       Inc(j);
  412.       CASE j OF
  413.         1,3,5: w := 10*w;
  414.         2,4: w := 6*w;
  415.         OTHERWISE w := 0;
  416.       END;
  417.     END;
  418.   END;
  419.   IF j<5 THEN Exit; { das kann keine Uhrzeit gewesen sein }
  420.   { der ganze device-Ärger: }
  421.   port := CreatePort('VT-timer',0);
  422.   t_ioreq := CreateExtIO(port,SizeOf(TimeRequest));
  423.   IF OpenDevice('timer.device',UNIT_VBLANK,Ptr(t_ioreq),0)=0 THEN BEGIN
  424.     { Uhrzeit erst lesen: }
  425.     t_ioreq^.tr_node.io_Command := TR_GETSYSTIME;
  426.     err := DoIO(Ptr(t_ioreq));
  427.     { Tageszeit ändern und neu setzten: }
  428.     t_ioreq^.tr_node.io_Command := TR_SETSYSTIME;
  429.     WITH t_ioreq^.tr_time DO BEGIN
  430.       tv_secs := (tv_secs DIV spd)*spd + secs; tv_micro := 0;
  431.     END;
  432.     err := DoIO(Ptr(t_ioreq));
  433.     { Und tschüss: }
  434.     CloseDevice(Ptr(t_ioreq));
  435.   END;
  436.   DeleteExtIO(t_ioreq);
  437.   DeletePort(port);
  438. END;
  439.  
  440. PROCEDURE clip_it{(s: Str; len: Long)};
  441. { String ins Clipboard schreiben }
  442. VAR err: Integer;
  443. BEGIN
  444.   IF clip_open THEN BEGIN
  445.     clipreq^.io_Command := CMD_WRITE;
  446.     clipreq^.io_Data := s;
  447.     clipreq^.io_Length := len;
  448.     err := DoIO(Ptr(clipreq));
  449.   END;
  450. END;
  451.  
  452. PROCEDURE start_clip{(size: Long)};
  453. BEGIN
  454.   IF clip_open THEN Exit;
  455.   clip_port := CreatePort('clipper',0);
  456.   clipreq := CreateExtIO(clip_port,SizeOf(IOClipReq));
  457.   IF OpenDevice('clipboard.device',PRIMARY_CLIP,Ptr(clipreq),0)=0 THEN BEGIN
  458.     clipreq^.io_Offset := 0;
  459.     clipreq^.io_ClipID := 0;
  460.     clip_open := True;
  461.     clip_it('FORM',4); { IFF-Header }
  462.     size := size + 12; clip_it(Ptr(^size),4); size := size - 12;
  463.     clip_it('FTXTCHRS',8);
  464.     clip_it(Ptr(^size),4);
  465.   END ELSE BEGIN
  466.     DeleteExtIO(clipreq);
  467.     DeletePort(clip_port);
  468.   END;
  469. END;
  470.  
  471. PROCEDURE end_clip;
  472. VAR err: Integer;
  473. BEGIN
  474.   IF clip_open THEN BEGIN
  475.     { melden, daß man fertig ist }
  476.     clipreq^.io_Command := CMD_UPDATE;
  477.     err := DoIO(Ptr(clipreq));
  478.     { Und tschüss: }
  479.     CloseDevice(Ptr(clipreq));
  480.     DeleteExtIO(clipreq);
  481.     DeletePort(clip_port);
  482.     clip_open := False;
  483.   END;
  484. END;
  485.  
  486. PROCEDURE telltime{(VAR day,min,tic: Long)};
  487. VAR time: DateStamp;
  488. BEGIN
  489.   IF _DateStamp(^time)<>Nil THEN BEGIN
  490.     day := time.ds_Days;
  491.     min := time.ds_Minute;
  492.     tic := time.ds_Tick;
  493.   END;
  494. END;
  495.  
  496. PROCEDURE desaster{(meldung: Str80)};
  497. { erzeugt einen Alert }
  498. VAR egal: Boolean;
  499.     buf: Str80;
  500.     xpos: Integer;
  501. BEGIN
  502.   xpos := 320 - 4*Length(meldung);
  503.   buf := '   '+meldung;
  504.   buf[1] := Chr(Hi(xpos)); buf[2] := Chr(Lo(xpos));
  505.   buf[3] := Chr(18);
  506.   buf [Length(meldung)+5] := Chr(0);
  507.   egal := DisplayAlert(RECOVERY_ALERT,buf,32);
  508. END;
  509.  
  510. PROCEDURE sysinit{(version: Str)};
  511. CONST charx = 8;  { für Menuetexte }
  512.       chary = 8;
  513. VAR i: Integer;
  514.     flags, cflags, breit: Word;
  515.     egal: Long;
  516.     for_vtview: Boolean;
  517. BEGIN
  518.   titel := copy(version,7,length(version)-6);
  519.   for_vtview := (titel[2]='T');  { Wer ruft sysinit() auf? }
  520.   { Zuerst Zeiger für den zugehörigen ExitServer initialisieren: }
  521.   IntuitionBase := Nil; GfxBase := Nil; DiskFontBase := Nil;
  522.   IconBase := Nil; ReqBase := Nil; AslBase := Nil;
  523.   MyScreen := Nil; MyWindow := Nil; teleFont := Nil;
  524.   oldwindowptr := Nil; BusyPointerData := Nil;
  525.   { Filerequester-Struktur initialisieren (in C wäre das nicht nötig!), }
  526.   { muß an dieser Stelle geschehen, damit PurgeFiles nicht abstürzt! }
  527.   FOR i := 0 TO SizeOf(ReqFileRequester)-1 DO
  528.     Mem[Long(^MyFileReq)+i] := 0;
  529.   { Libraries etc. öffnen: }
  530.   IntuitionBase := OpenLibrary('intuition.library',0);
  531.   GfxBase := OpenLibrary(GRAPHICSNAME,0);
  532.   DiskFontBase := OpenLibrary('diskfont.library',0);
  533.   IF NOT for_vtview THEN BEGIN
  534.     IconBase := OpenLibrary('icon.library',0);
  535.     AslBase := OpenLibrary(ASLNAME,0);
  536.     IF AslBase=Nil THEN ReqBase := OpenLibrary('req.library',0);
  537.   END;
  538.   IF IntuitionBase=Nil THEN Error('Can''t open intuition.library!');
  539.   IF GfxBase=Nil THEN Error('Can''t open graphics.library!');
  540.   IF DiskfontBase=Nil THEN desaster('Can''t open diskfont.library !!!');
  541.   { Screen: }
  542.   breite := 640; IF for_vtview THEN breite := 320;
  543.   hoehe := 256;
  544.   topazAttr := TextAttr('topaz.font',8,FS_NORMAL,FPF_ROMFONT);
  545.   { DrawInfo-Pens für den Screen angeben, damit das Depth-Gadget unter }
  546.   { Kick 2.0 gut aussieht. }
  547.   Pens[_DETAILPEN] := 0;    { \_ Screen-Titelleiste, wird aber von den }
  548.   Pens[_BLOCKPEN] := 1;     { /  entspr. Feldern im ExtNewScreen überstimmt }
  549.   Pens[TEXTPEN] := 1;   { Text in inaktiven Fensterleisten etc. }
  550.   Pens[SHINEPEN] := 2;     { \_für 3D- }
  551.   Pens[SHADOWPEN] := 1;    { /  Rahmen }
  552.   Pens[FILLPEN] := 3;         { \_Titelleiste aktiver }
  553.   Pens[FILLTEXTPEN] := 1;     { /  Fenster }
  554.   Pens[BACKGROUNDPEN] := 0;  { System-Requests, Gadgets inaktiver Fenster }
  555.   Pens[HIGHLIGHTTEXTPEN] := 2;   { "wichtiger Text" (???) }
  556.   Pens[9] := -1;
  557.   Tags[1] := TagItem(SA_Pens,Long(^Pens[0]));
  558.   Tags[2] := TagItem(TAG_DONE,0);
  559.   NeuerScreen := ExtNewScreen(0,0,breite,hoehe,3,0,1,HIRES or GENLOCK_VIDEO,
  560.     NS_EXTENDED OR CUSTOMSCREEN,^topazAttr,titel,Nil,Nil,^Tags[1]);
  561.   IF for_vtview THEN
  562.     NeuerScreen := ExtNewScreen(0,0,breite,hoehe,3,6,4,GENLOCK_VIDEO,
  563.             CUSTOMSCREEN,^topazAttr,titel,Nil,Nil,Nil);
  564.   MyScreen := OpenScreen(^NeuerScreen);
  565.   IF MyScreen=Nil THEN Error('Can''t open screen!');
  566.   FOR i := 0 TO 7 DO
  567.     SetRGB4(^MyScreen^.ViewPort, (colperm SHR (4*(7-i))) AND $F,
  568.       (palette[i] SHR 8) AND $F,(palette[i] SHR 4) AND $F,(palette[i]) AND $F);
  569.   IF for_vtview THEN FOR i := 0 TO 7 DO
  570.     SetRGB4(^MyScreen^.ViewPort, i, 15*(i AND 1), 15*((i DIV 2) AND 1),
  571.                                     15*((i DIV 4) AND 1));
  572.   { Fenster und Menue: }
  573.   NeuesWindow := NewWindow(0,16,breite,hoehe-16,0,1,
  574.         MENUPICK OR MOUSEBUTTONS OR REQCLEAR OR REQSET,
  575.         ACTIVATE OR BORDERLESS OR BACKDROP,
  576.         Nil,Nil,Nil,MyScreen,Nil,170,100,breite,hoehe,CUSTOMSCREEN);
  577.   MyWindow := OpenWindow(^NeuesWindow);
  578.   IF MyWindow=Nil THEN Error('Can''t open window!');
  579.   Menue1 := Menu(Nil,10,0,8*charx,0,MENUENABLED,'Projekt',^Mi[1],0,0,0,0);
  580.   { besonders häufige Flagkombinationen: }
  581.   Flags := ITEMTEXT or ITEMENABLED or HIGHCOMP; CFlags := Flags or COMMSEQ;
  582.   { Menueeinträge und Texte: }
  583.   { Projekt: Quit }
  584.   breit := (4+3)*charx + COMMWIDTH;
  585.   FOR i := 1 TO 1 DO
  586.     Mi[i] := MenuItem(Nil,0,(chary+2)*(i-1),breit,chary+2,CFlags,
  587.                    0,^MiT[i],Nil,chr(0),Nil,MENUNULL);
  588.   Mi[1].NextItem := Nil;    Mi[1].Command := 'Q';
  589.   MiT[1] := IntuiText(0,7,JAM1,5,1,Nil, 'Quit',Nil);
  590.   IF NOT for_vtview THEN
  591.     IF NOT SetMenuStrip(MyWindow,^Menue1) THEN
  592.       Error('Cannot install the menues - damn!');
  593.   { Font: }
  594.   teleAttr := TextAttr('videotext.font',9,FS_NORMAL,FPF_DISKFONT);
  595.   IF DiskFontBase<>Nil THEN
  596.     teleFont := OpenDiskFont(^teleAttr);
  597.   IF teleFont<>Nil THEN
  598.     egal := SetFont(MyWindow^.RPort,teleFont)
  599.   ELSE
  600.     desaster('Can''t open videotext.font !!!');
  601.   { Console einrichten: }
  602.   Con := OpenConsole(MyWindow);
  603.   SetStdIO(Con);
  604.   BusyPointerData := Ptr(AllocMem(SizeOf(WordArr36),MEMF_CHIP));
  605.   IF BusyPointerData<>Nil THEN
  606.     BusyPointerData^ := WordArr36(
  607.       $0000,$0000,
  608.       $0400,$07C0,$0000,$07C0,$0100,$0380,$0000,$07E0,
  609.       $07C0,$1FF8,$1FF0,$3FEC,$3FF8,$7FDE,$3FF8,$7FBE,
  610.       $7FFC,$FF7F,$7EFC,$FFFF,$7FFC,$FFFF,$3FF8,$7FFE,
  611.       $3FF8,$7FFE,$1FF0,$3FFC,$07C0,$1FF8,$0000,$07E0,
  612.       $0000,$0000
  613.     );
  614.   { meine Task finden und System Requests auf meinen Screen umleiten }
  615.   myprocess := Ptr(FindTask(Nil));
  616.   oldwindowptr := myprocess^.pr_WindowPtr;
  617.   myprocess^.pr_WindowPtr := MyWindow;
  618. END;
  619.  
  620. PROCEDURE sysclean;
  621. BEGIN
  622.   IF oldwindowptr<>Nil THEN myprocess^.pr_WindowPtr := oldwindowptr;
  623.   IF ReqBase<>Nil THEN BEGIN
  624.     PurgeFiles(^MyFileReq); CloseLibrary(ReqBase); END;
  625.   IF MyWindow<>Nil THEN BEGIN
  626.     ClearMenuStrip(MyWindow);
  627.     CloseWindow(MyWindow);
  628.   END;
  629.   IF MyScreen<>Nil THEN IF CloseScreen(MyScreen) THEN;
  630.   IF teleFont<>Nil THEN CloseFont(teleFont);
  631.   IF IntuitionBase<>Nil THEN CloseLibrary(IntuitionBase);
  632.   IF GfxBase<>Nil THEN CloseLibrary(GfxBase);
  633.   IF DiskFontBase<>Nil THEN CloseLibrary(DiskFontBase);
  634.   IF IconBase<>Nil THEN CloseLibrary(IconBase);
  635.   IF AslBase<>Nil THEN CloseLibrary(AslBase);
  636.   IF BusyPointerData <> Nil THEN FreeMem(Ptr(BusyPointerData),SizeOf(WordArr36));
  637.   { festhalten, daß alles geschlossen ist: }
  638.   ReqBase := Nil;
  639.   MyWindow := Nil;
  640.   MyScreen := Nil;
  641.   teleFont := Nil;
  642.   IntuitionBase := Nil;
  643.   GfxBase := Nil;
  644.   DiskFontBase := Nil;
  645.   IconBase := Nil;
  646.   AslBase := Nil;
  647.   BusyPointerData := Nil;
  648. END;
  649.  
  650. BEGIN  { Initialisierungsteil }
  651.   { RGB-Anteile der Farben in der Reihenfolge sw,rt,gn,gb,bl,vl,cn,ws: }
  652.   palette[0] := $000; palette[1] := $F00; palette[2] := $0F0;
  653.   palette[3] := $FF0; palette[4] := $00F; palette[5] := $F0F;
  654.   palette[6] := $0FF; palette[7] := $FFF;
  655.   colperm := $01234567;
  656.   clip_open := False;
  657. END.
  658.